Shareware Grab Bag/Shareware Grab Bag.iso/003/chrchpr2.arc/CSANSWRS.CMD

Text File | 1979-12-31 | 6.0 KB | 238 lines

* Program CSANSWRS - Allows entry of Survey answers for everyone in MEMBERSS.
Store d+':MEMBERSS' to MFILE
Select secondary
Use CSURVEY
GOTO 10
Store csanswrsx+' ' to valansw
Select primary
Use &MFILE index &MFILE
Store T to cscontin
Store F to invalcc
DO WHILE CSCONTIN
  If .not. invalcc
  ? 'Enter LAST NAME (3 characters) and FIRST NAME (2 characters) '
  Accept '  Name code ' to INHH
  Store T to invalcc
  Store F to MATCH
  Do while invalcc
    If len(INHH) = 1 .and. !(INHH) = 'Q'
      Store F to invalcc
      Store F to cscontin
    else
      If len(INHH) <> 5
  Accept 'Invalid entry - must be 5 characters. Please re-enter ' to INHH
      else
       Store !($(INHH,1,1))+$(INHH,2,2) to INLN
       Store !($(INHH,4,1))+$(INHH,5,1) to INFN
       Store F to invalcc
      endif
    endif
  enddo
  If CSCONTIN
  ? 'Matching ',trim(INLN),'..., ',trim(INFN),'...'
  Store T to MATCHINGL
  Store T to MATCHING
  FIND &INLN
  If # = 0
    Accept 'No match. Press <retn> to continue. ' to XX
  else
    Do while MATCHING
      Store T to PMATCHING
      Do while PMATCHING *(partial matching)
        Store T to NXTMATCH
        Do while NXTMATCH
          If EOF .or. $(last:name,1,3) <> INLN
            Store F to MATCHINGL
            Store F to MATCHING
            Store F to PMATCHING
            Store F to NXTMATCH
            Store F to MATCH
          else
           Store F to NXTMATCH
          endif
        enddo    * NXTMATCH
        If MATCHINGL
          If $(FIRST:NAME,1,2) = INFN
            Store F to PMATCHING
            Store T to MATCH
          else
             SKIP
          endif
        endif
      enddo  *(PMATCHING)
      If match
       ? 'Name: ',trim(last:name),', ',trim(first:name),'   Phone: ',home:phone
       Accept 'Is this the right name and phone? ' to xx
       If !(xx)='Y'
         Store F to MATCHING
       else
         Store T to MATCHING
         Store F to MATCH
         SKIP
       endif
     endif
   enddo    * (MATCHING)
 endif
 endif
 endif
 If MATCH
 Store $(P.ssscattd,1,20) to CSURV1
 Store $(P.ssscattd,21,20) to CSURV2
 Store $(P.ssscattd,41,19)+' ' to CSURV3
 Store '11' to SET
 Store '1' to II
 Store F to DONE
 Store '  ' to invala
 Store trim(P.last:name)+', '+trim(P.first:name) to xname
 Store '    TEL: '+P.home:phone to tel
 Do while .not.EOF .and. .not.DONE
  Store T to invalansw
  Erase
  Do while invalansw
   If '  '<>invala
    @ 23,0 say 'INVALID ANSWERS :'+invala
   else
    @ 1,26 say 'CHURCH SURVEY PROCESSING            '+CURDATE
    @ 2,0 say xname+tel
    @ 2,66 say MFILE
   endif
   Store 'A' to I
   Store 1 to cl
   Select secondary
   GOTO &SET
   Store val(II)*20-20 to III
   Do while cl<21
    If '  '=invala
      @ cl+2,0 say str(cl+III,2)+'.'
      @ cl+2,8 say csanswrsx+'  '+QU1
      Store $(csurv&II,cl,1) to NN&I
    endif
    @ cl+2,4 get NN&I
    SKIP
    Store cl+1 to cl
    Store chr(rank(I)+1) to I
  enddo
  READ
  If '  '<>valansw
    Store 'A' to I
    Store '  ' to invala
    Store 1 to cl
    Do while cl<21
      If @(NN&I,valansw)=0
        Store invala+str(cl+III,3) to invala
      endif
      Store cl+1 to cl
      Store chr(rank(I)+1) to I
    enddo
    If '  '=invala
      Store F to invalansw
    else
      @ 23,0 say ;
'                                                                             '
    endif
  else
    Store F to invalansw
  endif
  enddo
Accept ;
'Select: [N]ext screen    [B]ack a screen    [S]ave this record  [Q]uit ' TO ES
Store T to inval2
Do while inval2
  Store F to inval2
  Do CASE
  CASE !(ES)='S'
    STORE NNA+NNB+NNC+NND+NNE+NNF+NNG+NNH+NNI+NNJ+NNK+NNL+NNM+NNN+;
          NNO+NNP+NNQ+NNR+NNS+NNT TO CSURV&II
    Select primary
    Replace ssscattd with csurv1+csurv2+csurv3
    Store T to DONE
  CASE !(ES)='N'
    Store NNA+NNB+NNC+NND+NNE+NNF+NNG+NNH+NNI+NNJ+NNK+NNL+NNM+NNN+NNO to XX
    Store  XX+NNP+NNQ+NNR+NNS+NNT TO CSURV&II
    Select primary
    Replace ssscattd with csurv1+csurv2+csurv3
    If II='3'
      Accept 'Invalid entry - this is the last screen. enter again ' to es
      Store T to inval2
    else
      Store str(val(II)+1,1) to II
      Store str(11+val(II)*20,2) to SET
    endif
  CASE !(ES)='B'
    Store NNA+NNB+NNC+NND+NNE+NNF+NNG+NNH+NNI+NNJ+NNK+NNL+NNM+NNN+NNO to XX
    Store  XX+NNP+NNQ+NNR+NNS+NNT TO CSURV&II
    Select primary
    Replace ssscattd with csurv1+csurv2+csurv3
    If II='1'
      Accept 'Invalid entry - this is the first screen. Enter again ' to es
      Store T to inval2
    else
      Store str(val(II)-1,1) to II
      Store str(11+val(II)*20,2) to SET
    endif
  CASE !(es)='Q'
    Store T to done
    Select primary
  otherwise
    Accept 'Invalid entry. Please enter again [N/B/S/Q] ' to es
    Store T to inval2
  endcase
  enddo
 enddo
 ? 'Record for "',xname,'" is processed.'
 If len(es)=1
   Accept 'Select:  [N]ext name    [A]nother name    [Q]uit ' to ES
 else
   Store $(es,2,1) to ES
 endif
 Store T to inval2
 Do while inval2
  Store F to inval2
  DO CASE
  CASE !(ES)='N'
    SKIP
    If EOF
      Store F to CSCONTIN
    else
      Store T to invalcc
    endif
  CASE !(ES)='A'
    Store F to invalcc
    If EOF
      Store F to CSCONTIN
    endif
  CASE !(ES)='Q'
    USE
    Store F to CSCONTIN
  otherwise
    Accept 'Invalid entry. Please enter again [N/B/Q] ' to ES
    Store T to inval2
  ENDCASE
enddo
else
 If CSCONTIN
  Accept 'No match for this name. Press <retn> ' to xx
 endif
endif
enddo
RETURN

tore F to PMATCHING
            Store T to MATCH
          else
             SKIP
          endif
        endif
      enddo  *(PMATCHING)
      If match
       ? 'Name: ',trim(last:name),', ',trim(first:name),'   Phone: ',home:phone
       Accept 'Is this the right name and phone? ' to xx
       If !(xx)='Y'
         Store F to MATCHING
       else
         Store T to MATCHING
         Store F to MATCH
         SKIP
       endif
     endif
   end